home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / emacs_src_18_58.lha / emacs-18.58 / lisp / mailalias.el < prev    next >
Lisp/Scheme  |  1992-02-21  |  6KB  |  147 lines
  1. ;; Expand mailing address aliases defined in ~/.mailrc.
  2. ;; Copyright (C) 1985, 1987 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is free software; you can redistribute it and/or modify
  7. ;; it under the terms of the GNU General Public License as published by
  8. ;; the Free Software Foundation; either version 1, or (at your option)
  9. ;; any later version.
  10.  
  11. ;; GNU Emacs is distributed in the hope that it will be useful,
  12. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;; GNU General Public License for more details.
  15.  
  16. ;; You should have received a copy of the GNU General Public License
  17. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  18. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20.  
  21. ;; Called from sendmail-send-it, or similar functions,
  22. ;; only if some mail aliases are defined.
  23. (defun expand-mail-aliases (beg end)
  24.   "Expand all mail aliases in suitable header fields found between BEG and END.
  25. Suitable header fields are To, Cc and Bcc."
  26.   (if (eq mail-aliases t)
  27.       (progn (setq mail-aliases nil) (build-mail-aliases)))
  28.   (goto-char beg)
  29.   (setq end (set-marker (make-marker) end))
  30.   (let ((case-fold-search nil))
  31.     (while (let ((case-fold-search t))
  32.          (re-search-forward "^\\(to\\|cc\\|bcc\\):" end t))
  33.       (skip-chars-forward " \t")
  34.       (let ((beg1 (point))
  35.         end1 pos epos seplen
  36.         ;; DISABLED-ALIASES records aliases temporarily disabled
  37.         ;; while we scan text that resulted from expanding those aliases.
  38.         ;; Each element is (ALIAS . TILL-WHEN), where TILL-WHEN
  39.         ;; is where to reenable the alias (expressed as number of chars
  40.         ;; counting from END1).
  41.         (disabled-aliases nil))
  42.     (re-search-forward "^[^ \t]" end 'move)
  43.     (beginning-of-line)
  44.     (skip-chars-backward " \t\n")
  45.     (setq end1 (point-marker))
  46.     (goto-char beg1)
  47.     (while (< (point) end1)
  48.       (setq pos (point))
  49.       ;; Reenable any aliases which were disabled for ranges
  50.       ;; that we have passed out of.
  51.       (while (and disabled-aliases (> pos (- end1 (cdr (car disabled-aliases)))))
  52.         (setq disabled-aliases (cdr disabled-aliases)))
  53.       ;; EPOS gets position of end of next name;
  54.       ;; SEPLEN gets length of whitespace&separator that follows it.
  55.       (if (re-search-forward "[ \t]*[\n,][ \t]*" end1 t)
  56.           (setq epos (match-beginning 0)
  57.             seplen (- (point) epos))
  58.         (setq epos (marker-position end1) seplen 0))
  59.       (let (translation
  60.         (string (buffer-substring pos epos)))
  61.         (if (and (not (assoc string disabled-aliases))
  62.              (setq translation
  63.                (cdr (assoc string mail-aliases))))
  64.         (progn
  65.           ;; This name is an alias.  Disable it.
  66.           (setq disabled-aliases (cons (cons string (- end1 epos))
  67.                            disabled-aliases))
  68.           ;; Replace the alias with its expansion
  69.           ;; then rescan the expansion for more aliases.
  70.           (goto-char pos)
  71.           (insert translation)
  72.           (delete-region (point) (+ (point) (- epos pos)))
  73.           (goto-char pos))
  74.           ;; Name is not an alias.  Skip to start of next name.
  75.           (goto-char epos)
  76.           (forward-char seplen))))
  77.     (set-marker end1 nil)))
  78.     (set-marker end nil)))
  79.  
  80. ;; Called by mail-setup, or similar functions, only if ~/.mailrc exists.
  81. (defun build-mail-aliases (&optional file)
  82.   "Read mail aliases from ~/.mailrc and set mail-aliases."
  83.   (setq file (expand-file-name (or file "~/.mailrc")))
  84.   (let ((buffer nil)
  85.     (obuf (current-buffer)))
  86.     (unwind-protect
  87.     (progn
  88.       (setq buffer (generate-new-buffer "mailrc"))
  89.       (buffer-flush-undo buffer)
  90.       (set-buffer buffer)
  91.       (cond ((get-file-buffer file)
  92.          (insert (save-excursion
  93.                (set-buffer (get-file-buffer file))
  94.                (buffer-substring (point-min) (point-max)))))
  95.         ((not (file-exists-p file)))
  96.         (t (insert-file-contents file)))
  97.       ;; Don't lose if no final newline.
  98.       (goto-char (point-max))
  99.       (or (eq (preceding-char) ?\n) (newline))
  100.       (goto-char (point-min))
  101.       ;; handle "\\\n" continuation lines
  102.       (while (not (eobp))
  103.         (end-of-line)
  104.         (if (= (preceding-char) ?\\)
  105.         (progn (delete-char -1) (delete-char 1) (insert ?\ ))
  106.             (forward-char 1)))
  107.       (goto-char (point-min))
  108.       (while (or (re-search-forward "^a\\(lias\\|\\)[ \t]+" nil t)
  109.              (re-search-forward "^g\\(roup\\|\\)[ \t]+" nil t))
  110.         (re-search-forward "[^ \t]+")
  111.         (let* ((name (buffer-substring (match-beginning 0) (match-end 0)))
  112.            (start (progn (skip-chars-forward " \t") (point))))
  113.           (end-of-line)
  114.           (define-mail-alias
  115.         name
  116.         (buffer-substring start (point)))))
  117.       mail-aliases)
  118.       (if buffer (kill-buffer buffer))
  119.       (set-buffer obuf))))
  120.  
  121. ;; Always autoloadable in case the user wants to define aliases
  122. ;; interactively or in .emacs.
  123. (defun define-mail-alias (name definition)
  124.   "Define NAME as a mail-alias that translates to DEFINITION."
  125.   (interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
  126.   ;; Read the defaults first, if we have not done so.
  127.   (if (eq mail-aliases t)
  128.       (progn
  129.     (setq mail-aliases nil)
  130.     (if (file-exists-p "~/.mailrc")
  131.         (build-mail-aliases))))
  132.   (let (tem)
  133.     ;; ~/.mailrc contains addresses separated by spaces.
  134.     ;; mailers should expect addresses separated by commas.
  135.     (while (setq tem (string-match "[^ \t,][ \t,]+" definition tem))
  136.       (if (= (match-end 0) (length definition))
  137.       (setq definition (substring definition 0 (1+ tem)))
  138.     (setq definition (concat (substring definition
  139.                         0 (1+ tem))
  140.                  ", "
  141.                  (substring definition (match-end 0))))
  142.     (setq tem (+ 3 tem))))
  143.     (setq tem (assoc name mail-aliases))
  144.     (if tem
  145.     (rplacd tem definition)
  146.       (setq mail-aliases (cons (cons name definition) mail-aliases)))))
  147.